Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part07

Text File | 1987-08-01 | 50.4 KB | 1,586 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i081:  Common Ojbects, Common Loops, Common Lisp, Part07/13
Message-ID: <[e-mail]>
Date: 3 Aug 87 03:01:21 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1575
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 81
Archive-name: comobj.lisp/Part07

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 7 (of 13)."
# Contents:  co-dmeth.l macros.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-dmeth.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'co-dmeth.l'\"
else
echo shar: Extracting \"'co-dmeth.l'\" \(22335 characters\)
sed "s/^X//" >'co-dmeth.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         co-dmeth.l
X; RCS:          $Revision: 1.1 $
X; SCCS:         %A% %G% %U%
X; Description:  Defining CommonObjects methods
X; Author:       James Kempf
X; Created:      March 10, 1987
X; Modified:     12-Mar-87 09:21:38 (James Kempf)
X; Language:     Lisp
X; Package:      COMMON-OBJECTS
X; Status:       Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted.  Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; [e-mail]
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;  nued) Support for Using Keywords as Method Names
X;
X;  These macros and functions translate keyword method names into
X;  names in a package. Some Common Lisps do allow keyword symbols
X;  to have an associated function, others don't. Rather than
X;  differentiating, a single package, KEYWORD-STANDIN, is used
X;  for method symbols which are keywords.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun keyword-standin (keyword)
X
X  ;;An example of a special method is :print which gets
X  ;;  translated into the symbol pcl:print-instance
X
X  (if (special-keyword-p keyword)
X    (keyword-standin-special keyword)
X    (intern (symbol-name keyword) *keyword-standin-package*)
X  )
X
X) ;end keyword-standin
X
X;;unkeyword-standin-Return the keyword for a standin symbol
X
X(defun unkeyword-standin (symbol)
X
X  (if (special-method-p symbol)
X    (unkeyword-standin-special symbol)
X      (if (eq (symbol-package symbol) *keyword-standin-package*)
X    (setf symbol (intern (symbol-name symbol) (find-package :keyword)))
X    symbol
X
X       ) ;if
X
X  ) ;if
X
X) ;end unkeyword-standin
X
X;;Set up the universal method selector list, for fast messaging
X
X(eval-when (load eval)
X  (dolist (l *universal-methods*)
X    (push (keyword-standin l) *universal-method-selectors*)
X  )
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;    Runtime Interface to the Slots
X;
X;  The extra slots are used for the pointer to self and for parents. Each
X;  ancestor is actually a fully fledged object of the ancestor type, except its
X;  pointer to self slot points back to the original object piece.
X;  Slot indicies can be calculated directly at compile time, since they do
X;  not change after the object is created.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;self-from-inner-self-Return the pointer to the original object
X
X(defmacro self-from-inner-self ()
X  `(%instance-ref .inner-self. ,$SELF-INDEX)
X
X) ;end self-from-inner-self
X
X;;parent-from-inner-self-Given the parent's name, return a pointer
X;;  to the object piece in which the instance variables are stored.
X
X(defmacro parent-from-inner-self (parent-class-name)
X  `(get-slot .inner-self. ',(local-super-slot-name parent-class-name))
X
X) ;end parent-from-inner-self
X
X;;local-super-slot-name-Generate a slot name for the parent's instance
X;;  variable
X
X(defun local-super-slot-name (local-super-name)
X  (intern (concatenate 'string
X        "Slot For "
X            (symbol-name local-super-name)))
X
X) ;end local-super-slot-name
X
X;;calculate-slot-index-Return the index of the slot in the vector
X
X(defun calculate-slot-index (slotname parents slots)
X
X  (let
X    (
X      (parloc (position slotname parents))
X      (sloc  (position slotname slots))
X    )
X
X    (if parloc
X     (+ $START-OF-PARENTS parloc)
X     (+ $START-OF-PARENTS (length parents) sloc)
X    )
X
X  )
X
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;    New Method Class For CommonObjects
X;
X;  CommonObjects methods need to keep track of their method symbol, so
X;  that the symbol can be looked up and inserted into a CALL-METHOD
X;  or APPLY-METHOD when a method including one of these forms is loaded.
X;  The new method keeps track of a method symbol as an instance variable,
X;  and maintains the symbol's function cell with an accurate pointer to
X;  the current function implementing the method. The function is called
X;  through this symbol during run-time processing of a CALL-METHOD.
X;  Note that, since the method object gets created when the method
X;  is loaded (or, alternatively, looked up, if a CALL-METHOD was
X;  processed before the method was defined), the symbol will be GENSYM'ed
X;  in the load time environment. Fully qualified symbols are needed for
X;  the method names because they are not exported from the PCL package.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;common-objects-method-Add an additional slot for the function symbol name
X
X(ndefstruct
X  (common-objects-method (:class class)
X    (:include pcl::method)
X    (:conc-name method-)
X  )
X    (function-symbol NIL)    ;;name of the method function
X                ;;  used for call-method
X
X) ;end common-objects-method
X
X;;method-function-Need this to have the SETF
X;;  method work correctly
X
X(defmeth method-function  ((method common-objects-method))
X
X  ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X  ;;  new code.
X
X  (call-next-method)
X
X
X) ;end method-function
X
X;;method-function-Even though we may not yet be able to
X;;  determine what the function symbol is, the SETF method
X;;  must reset the symbol's function, in the event the
X;;  method object is recycled.
X
X(defmeth (method-function (:setf (nv))) ((method common-objects-method))
X
X
X    ;;If the method function symbol for the CALL-METHOD optimization
X    ;;  has not yet been set, do it.
X
X    (when (method-function-symbol method)
X      (setf (symbol-function (method-function-symbol method))
X        nv
X      )
X
X    )
X
X
X    ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X    ;; new code.
X
X    (call-next-method)
X
X) ;end method-function :setf
X
X;;method-discriminator-Need this to have the SETF
X;;  method work correctly
X
X(defmeth method-discriminator  ((method common-objects-method))
X
X  ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X  ;;  new code.
X
X  (call-next-method)
X
X
X) ;end method-discriminator
X
X;;method-discriminator-By the time the method's discriminator is
X;;  set, the method has enough information to generate the
X;;  symbol for CALL-METHOD optimization.
X
X(defmeth (method-discriminator (:setf (nv))) ((method common-objects-method))
X
X
X    ;;If the method function symbol for the CALL-METHOD optimization
X    ;;  has not yet been set, do it.
X
X    (when (not (method-function-symbol method))
X      (setf (method-function-symbol method)
X            (generate-method-function-symbol
X          (class-name (car (method-type-specifiers method)))
X          (discriminator-name nv)
X        )
X      )
X      (setf (symbol-function (method-function-symbol method))
X        (method-function method)
X      )
X
X    )
X
X
X    ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X    ;; new code.
X
X    (call-next-method)
X
X) ;end method-discriminator :setf
X
X;;generate-method-function-symbol-Generate a method function
X;;  symbol for the method. Used in the CALL-METHOD optimization.
X
X(defun generate-method-function-symbol (class-name message)
X
X  ;;Generate a symbol for the function to be called.
X  ;;  This is in the same package as the method name
X  ;;  symbol, and its name as the form:
X  ;;  <class package name>;;<class name> <message package name>;;<message>
X  ;;  Note that this will avoid collisions for two methods with
X  ;;  the same name and different packages, because the symbol
X  ;;  names (as well as the packages) are different.
X  ;;  We hope that this should avoid collision.
X
X  (intern
X    (concatenate 'simple-string
X         (package-name (symbol-package class-name))
X         ";;"
X         (symbol-name class-name)
X         " "
X         (package-name
X           (if (keywordp message)
X                     (find-package 'keyword-standin)
X                     (symbol-package message)
X                   )
X                 )
X         ";;"
X         (symbol-name message)
X    )
X    (if (keywordp message)
X      (find-package 'keyword-standin)
X      (symbol-package message)
X    )
X )
X
X) ;generate-method-function-symbol
X
X;;expand-with-make-entries-Returns an alist of the form:
X;;
X;;   (<prefix+slot-name> <instance-form> <class> <slotd> <use-slot-value-p>)
X;;
X
X(defmeth expand-with-make-entries ((method common-objects-method) first-arg)
X         (declare (ignore first-arg))   ; rds 3/8
X  (let*
X    (
X      (entries ())
X      (method-argument (first (method-arglist method)))
X      (method-type-spec (first (method-type-specifiers method)))
X    )
X
X    ;;CommonObjects methods only discriminate on the first
X    ;;  argument. Also, we always want to use the slot value,
X    ;;  since there is no slotd-accessor.
X
X    (dolist (slotd (class-slots method-type-spec))
X      (push
X        (list
X          (slotd-name slotd)    ;;the slot name
X          method-argument    ;;the instance arg name
X          method-type-spec    ;;the class
X          slotd            ;;the slot descriptor
X          T                  ;;use the slot value directly
X        )
X        entries
X      )
X    ) ;dolist
X
X    entries
X
X  ) ;let*
X
X) ;expand-with-make-entries
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;              Messaging Macros and Functions
X;
X;   Message sending becomes funcalling the message.
X;   We convert all message sends to a funcall of the message.  Because
X;   CommonObjects encourages messages to be keywords and keywords are
X;   not funcallable, we have to have a special package in which keywords
X;   are interned before their use as messages.
X;
X;   As an example of all this, take the expansion of a sample =>:
X;
X;      (=> object :message arg-1 arg-2)  expands into:
X;
X;      (funcall 'keyword-standin::message object arg-1 arg-2)
X;
X;   This means that all CommonObjects discriminators will be classical.
X;   That is they will discriminator only on the class of their first
X;   argument.
X;
X;   The first argument to any method will always be the inner self, that is
X;   an instance of the same class as the method was defined on.  This is
X;   bound to the symbol .INNER-SELF., special macros SELF-FROM-INNER-SELF
X;   and PARENT-FROM-INNER-SELF are used to access outer-self and parent
X;   instances.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;make-set-message-Construct a :SET-xxx message for SETF
X
X(defmacro make-set-message (message)
X
X  `(intern
X    (concatenate 'simple-string
X                 "SET-"
X                 (symbol-name ,message)
X    )
X    (symbol-package ,message)
X
X  )
X
X) ;make-set-message
X
X;;=>-Convert to PCL messaging. Note that no error or type checking occurs.
X
X(defmacro => (object message &rest args)
X
X  `(funcall
X      ,(if (keywordp message)
X    `',(keyword-standin message)
X        message
X      )
X      ,object
X      ,@args
X  )
X
X) ;end =>
X
X;;send?-Messaging macro which returns NIL if something is wrong.
X
X(defmacro send? (object message &rest args)
X
X  `(send?-internal
X    ,object
X    ,(if (keywordp message)
X    `',(keyword-standin message)
X     message
X    )
X    ,@args
X  )
X
X) ;end send?
X
X;;Setf definitions for messaging macros.
X
X(defsetf => (obj message) (new-value)
X
X  `(progn
X      (=> ,obj
X          ,(if (keywordp message)
X            (make-set-message message)
X            `(make-set-message ,message)
X          )
X      ,new-value
X      )
X    )
X) ;end defsetf for =>
X
X(defsetf send? (obj message) (new-value)
X  `(progn
X      (send? ,obj
X             ,(if (keywordp message)
X               (make-set-message message)
X               `(make-set-message ,message)
X              )
X        ,new-value
X      )
X    )
X) ;end defsetf for send?
X
X;;send?-internal-Process the message invocation into correct code for
X;; SEND?
X
X(defun send?-internal (object message &rest args)
X
X  (if object
X    (let*
X       (
X         (class (class-of object))
X         (class-name (class-name class))
X         (metaclass-name (class-name (class-of class)))
X
X       )
X
X      ;;Check if OBJECT is an instance and class is still defined
X      ;;  and operation is supported.
X
X      (if (and
X           (eq metaclass-name 'common-objects-class)
X           (not (eq class-name $UNDEFINED-TYPE-NAME))
X           (fast-supports-operation-p class message)
X          )
X
X          (apply message  object args)
X
X          NIL
X
X      ) ;if
X
X    ) ;let*
X
X  ) ;if
X
X) ;send?-internal
X
X;;fast-supports-operation-p-Does no checking on CLASS
X
X(defun fast-supports-operation-p (class message)
X
X;;Check first if its a universal method
X
X  (if (member (unkeyword-standin message) *universal-methods*)
X
X    T
X
X    ;;Otherwise, check in the class object if it's got them
X
X    (dolist (methobj (pcl::class-direct-methods class))
X
X      (when (eq (method-name methobj) message)
X        (return-from fast-supports-operation-p T)
X      )
X
X    ) ;dolist
X  ) ;if
X
X) ;fast-supports-operation-p
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;  Method Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;defcommon-objects-meth-Create method and discriminator objects and
X;;  call EXPAND-DEFMETH-INTERNAL. The method object is of class
X;;  common-objects-method. Note that this macro gets expanded at the
X;;  time this file is compiled.
X
X(defmacro defcommon-objects-meth (message arglist body)
X
X
X  `(let
X    (
X      (discriminator-class-object (class-named 'pcl::discriminator t))
X      (method-class-object (class-named 'common-objects-method t))
X    )
X
X    (pcl::expand-defmeth-internal (class-prototype discriminator-class-object)
X                      (class-prototype method-class-object)
X                      (if (listp ,message) ,message (list ,message))
X                      ,arglist
X                      (list ,body)
X    )
X
X  ) ;let
X
X) ;end defcommon-objects-meth
X
X;;define-method-Top level programmer interface to method
X;;  definition
X
X(defmacro define-method (spec arglist &body body)
X
X  ;;Syntax check the call first
X
X  (co-parse-method-macro-call spec arglist body)
X
X  (let*
X    (
X      (class-name (car spec))
X      (message (if (keywordp (cadr spec))
X             (keyword-standin (cadr spec))
X             (cadr spec)))
X    )
X
X
X    ;;Check first to be sure that class is a CommonObjects class
X
X    (if (not
X          (eq (class-name (class-of (class-named class-name T))) 'common-objects-class)
X        )
X      (error "DEFINE-METHOD: `~S' is not a CommonObjects type." class-name)
X    )
X
X    ;;The compiler-let of *CURRENT-METHOD-CLASS-NAME* is to support
X    ;;  CALL-METHOD.
X    ;;  Also, bind SELF around the body to outer self.
X    ;;  Note that this allows someone to rebind SELF in the body, but
X    ;;  that rebinding will not affect CALL-METHOD, APPLY-METHOD or IV
X    ;;  access since they don't really use SELF.
X    ;;  Also, use WITH to allow lexical access to the instance
X    ;;  variables.
X
X    (setq body `(compiler-let
X                  (
X                    (*current-method-class-name* ',class-name)
X              )
X
X                  (let ((self (self-from-inner-self)))
X            (with*
X              (
X            (.inner-self. "" ,class-name)
X              )
X
X                      self
X              (progn . ,body))
X                 )
X
X          ) ;compiler-let
X    )
X
X
X    `(progn
X
X        ,(defcommon-objects-meth message
X           `((.inner-self. ,class-name) ,@arglist)
X
X       body
X
X         )
X
X         (list ',class-name ',(cadr spec))
X
X       ) ;progn
X
X   ) ;let*
X
X) ;end define-method
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X;    Call-Method and Optimizations
X;
X;  Because of pf the ambiguous nature of the definition of #, in CLtL,
X;  the implementation of #, may not work correctly on a particular system
X;  when used within the backquote macro in compiled code.
X;  The kind of behavior which is needed is as follows (with reference
X;  to 5.3.3, pg. 70)
X;
X;  1) If the situation is EVAL, then execute the function
X;     LOAD-TIME-GET-CALL-METHOD-FUNCTION-SYMBOL and cache the
X;     method symbol in line when the code is macroexpanded.
X;
X;  2) If the situation is compile, then arrange for the function
X;     LOAD-TIME-GET-CALL-METHOD-FUNCTION-SYMBOL to be executed
X;     and the result cached only when the file gets loaded.
X;
X;  What I want to say is:
X;
X;   `(,caller
X;         #,(load-time-get-call-method-function ',class-name ',method-name
X;                           ',arglist
X;          )
X;          <rest of form>
X;     )
X;
X;  and have it work correctly. Well, it doesn't always.
X;
X;  Alternatively, I would like to generate a closure at compile time
X;  which will get fasled into the output file and will cache the
X;  method symbol the first time it is called. But that doesn't
X;  always work either.
X;
X;  So, instead, I tried using an elaborate scheme which creates vectors
X;  at compile time and uses a top level (EVAL-WHEN (LOAD) ...) to
X;  depost the method symbol at load time. The special variable
X;  *LIST-OF-CALL-METHOD-FIXUPS* gets bound to NIL before every
X;  DEFINE-METHOD invocation. The CALL-METHOD macro creates
X;  instances of the DEFSTRUCT CALL-METHOD-RECORD and pushes them
X;  on *LIST-OF-CALL-METHOD-FIXUPS* recording CALL-METHODs and
X;  vectors for caching the method symbol. The CALL-METHOD macro
X;  can do this because the PCL method EXPAND-DEFMETH-INTERNAL
X;  is replaced in the patches file. This new method walks
X;  them method code body during the execution of EXPAND-DEFMETH-INTERNAL
X;  rather than at the top level, as in the stock PCL system.
X;  If this change is NOT made, then the method body must
X;  be prewalked before code generation, because the code
X;  walk (during which CALL-METHOD gets expanded) doesn't
X;  occur until after DEFINE-METHOD returns to the top level.
X;
X;  As the last part of the DEFINE-METHOD code generation,
X;  a top level (EVAL-WHEN (LOAD EVAL) ...) is generated to get
X;  the method symbol at load time and deposit it in the
X;  vector. The SVREF gets the symbol at the time the CALL-METHOD
X;  is invoked. So, in effect, I'm generating my own
X;  closure.
X;
X;  Well, that doesn't work either. Why? Because once the
X;  vector is deposited into the code, there is no guarantee
X;  that it will be EQ to the one in the list. And, in any
X;  event, this scheme won't work in traditional interpreters
X;  which expand macros as they are encountered, since the
X;  top level (EVAL-WHEN (LOAD EVAL) ... ) gets done before
X;  the CALL-METHOD macro is fully expanded.
X;
X;  Sigh. The only choice is to GENSYM a symbol at compile
X;  time and pray that it doesn't trash something at load time.
X;  But maybe that's OK.
X;
X;  Note that the general behavior which is desired here is loadtime
X;  execution within generated code, rather than at the top level.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;call-method-Top level macro for CALL-METHOD.
X
X(defmacro call-method (spec &rest args)
X  (call-method-internal 'call-method spec args)
X
X) ;end call-method
X
X;;apply-method-Top level macro for APPLY-METHOD.
X
X(defmacro apply-method (spec &rest args)
X  (call-method-internal 'apply-method spec args)
X
X) ;end apply-method
X
X;;call-method-internal-Process a CALL-METHOD invocation.
X
X(defun call-method-internal (for spec args)
X  (declare (special *current-method-class-name*))
X  (if (null (boundp '*current-method-class-name*))
X      (error "Attempt to use ~S other than inside a method.~%" for)
X      (let* ((caller (ecase for
X              (call-method 'funcall)
X              (apply-method 'apply)))
X        (class-name (if (listp spec)
X                (car spec)
X                *current-method-class-name*))
X        (message (if (listp spec) (cadr spec) spec))
X
X        (fsym (generate-method-function-symbol class-name message))
X
X          )
X
X
X         ;;Check the syntax
X
X         (co-parse-call-to-method (list for spec args)
X                                  (symbol-name for)
X                                  *current-method-class-name*
X         )
X
X
X         ;;Generate code. Note there is no need to check
X         ;;  whether or not the method function symbol
X         ;;  is bound or to do any fixing up at all.
X         ;;  If it is not, then its an error, because
X         ;;  the method hasn't yet been defined. The
X         ;;  function cell will be bound when the
X         ;;  method gets defined.
X
X    `(,caller (symbol-function ',fsym)
X
X      ,(if (listp spec)
X           `(parent-from-inner-self ,class-name)
X           '.inner-self.)
X      ,@args)
X    ) ;let
X  ) ;if
X
X) ;end call-method-internal
X
X
X;;legal-parent-p-Is parent-name a legal parent of class-name?
X
X(defun legal-parent-p (class-name parent-name)
X
X  (member parent-name
X          (class-local-super-names (class-named class-name T))
X          :test #'eq
X
X  )
X) ;legal-parent-p
X
X
END_OF_FILE
if test 22335 -ne `wc -c <'co-dmeth.l'`; then
    echo shar: \"'co-dmeth.l'\" unpacked with wrong size!
fi
# end of 'co-dmeth.l'
fi
if test -f 'macros.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'macros.l'\"
else
echo shar: Extracting \"'macros.l'\" \(25561 characters\)
sed "s/^X//" >'macros.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Macros global variable definitions, and other random support stuff used
X;;; by the rest of the system.
X;;;
X;;; For simplicity (not having to use eval-when a lot), this file must be
X;;; loaded before it can be compiled.
X;;;
X
X(in-package 'pcl :nicknames '(portable-commonloops) :use '(lisp walker))
X
X(export '(defclass
X      defmethod
X      print-object
X
X      print-instance
X      ndefstruct
X      defmeth
X      run-super
X      make
X      initialize
X      get-slot
X      with
X      with*
X      class-of
X      class-named
X      discriminator-named
X      class-prototype
X      class
X      object
X
X
X
X      essential-class
X
X      class-name
X      class-precedence-list
X      class-local-supers
X      class-local-slots
X      class-direct-subclasses
X      class-direct-methods
X      class-slots
X
X
X      essential-discriminator
X
X      discriminator-name
X      discriminator-methods
X      discriminator-discriminating-function
X
X      essential-method
X
X      method-discriminator
X      method-arglist
X      method-argument-specifiers
X      method-function
X
X      method-equal
X
X      discriminator-methods
X
X      slotd-name
X      slot-missing
X
X      define-meta-class
X      %make-instance
X      %instance-ref
X      %instancep
X      %instance-meta-class
X
X      make-instance
X      get-slot
X      put-slot
X      get-slot-using-class
X      optimize-slot-access
X      define-class-of-clause
X      add-named-class
X      class-for-redefinition
X      add-class
X      supers-changed
X      slots-changed
X      check-super-meta-class-compatibility
X      check-meta-class-change-compatibility
X      make-slotd
X      compute-class-precedence-list
X      walk-method-body
X      walk-method-body-form
X      optimize-get-slot
X      optimize-set-of-get-slot
X      variable-lexical-p
X      add-named-method
X      add-method
X      remove-named-method
X      remove-method
X      find-method
X      find-method-internal
X      make-discriminating-function
X      install-discriminating-function
X      no-matching-method
X      class-class-precedence-list
X      class-local-supers
X      class-direct-subclasses
X      class-name
X
X      )
X    (find-package 'pcl))
X
X(proclaim '(declaration values            ;I use this so that Zwei can
X                        ;remind me what values a
X                        ;function returns.
X
X            method-function-name    ;This is used so that some
X                        ;systems can print the name
X                        ;of the method when I am in
X                        ;the debugger.
X                        ))
X
X;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
X;;; in other packages in all CommonLisp implementations, but I will leave it
X;;; to the compiler to optimize into calls to them.
X;;;
X;;; Common Lisp BUG:
X;;;    Some Common Lisps define these in the Lisp package which causes
X;;;    all sorts of lossage.  Common Lisp should explictly specify which
X;;;    symbols appear in the Lisp package.
X;;;
X(defmacro memq (item list) `(member ,item ,list :test #'eq))
X(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
X(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
X(defmacro delq (item list) `(delete ,item ,list :test #'eq))
X(defmacro neq (x y) `(not (eq ,x ,y)))
X
X(defun make-caxr (n form)
X  (if (< n 4)
X      `(,(nth n '(car cadr caddr cadddr)) ,form)
X      (make-caxr (- n 4) `(cddddr ,form))))
X
X(defun make-cdxr (n form)
X  (cond ((zerop n) form)
X    ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
X    (t (make-cdxr (- n 4) `(cddddr ,form)))))
X
X(defmacro ignore (&rest vars)
X  #+Symbolics `(progn ,.(remove 'ignore vars))
X  #-Symbolics `(progn ,@vars))
X
X(defun true (&rest ignore) (ignore ignore) t)
X(defun false (&rest ignore) (ignore ignore) nil)
X
X;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just
X;;; lifted it from there but I am honest.  Not only that but this one is
X;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
X;;; like rebuilding Rome.
X(defmacro once-only (vars &body body)
X  (let ((gensym-var (gensym))
X        (run-time-vars (gensym))
X        (run-time-vals (gensym))
X        (expand-time-val-forms ()))
X    (dolist (var vars)
X      (push `(if (or (symbolp ,var)
X                     (numberp ,var)
X                     (and (listp ,var)
X              (member (car ,var) '(quote function))))
X                 ,var
X                 (let ((,gensym-var (gensym)))
X                   (push ,gensym-var ,run-time-vars)
X                   (push ,var ,run-time-vals)
X                   ,gensym-var))
X            expand-time-val-forms))
X    `(let* (,run-time-vars
X            ,run-time-vals
X            (wrapped-body
X              ((lambda ,vars . ,body) . ,(reverse expand-time-val-forms))))
X       `((lambda ,(nreverse ,run-time-vars)  ,wrapped-body)
X         . ,(nreverse ,run-time-vals)))))
X
X(defun extract-declarations (body &optional environment)
X  (declare (values documentation declares body))
X  (let (documentation declares form temp)
X    (when (stringp (car body)) (setq documentation (pop body)))
X    (loop
X      (when (null body) (return))
X      (setq form (car body))
X      (cond ((and (listp form) (eq (car form) 'declare))
X         (push (pop body) declares))
X;        ((and (neq (setq temp (macroexpand form environment)) form)
X;          (listp temp)
X;          (eq (car temp) 'declare))
X;         (pop body)
X;         (push temp declares))
X        (t (return))))
X    (values documentation declares body)))
X
X  ;;
X;;;;;; FAST-NCONC Lists
X  ;;
X;;; These are based on Interlisp's TCONC function.  They are slighlty
X;;; generalized to take either the item to nconc onto the end of the list or
X;;; a cons to add to the end of a list. In addition there is a constructor to
X;;; make fast-nconc-lists and an accessor to get at a fast-nconc-list's real
X;;; list.
X(defmacro make-fast-nconc-list ()
X  `(let ((fast-nconc-list (cons () (list ()))))
X     (rplaca fast-nconc-list (cdr fast-nconc-list))
X     fast-nconc-list))
X
X(defmacro fast-nconc-list-real-list (fast-nconc-list)
X  `(cddr ,fast-nconc-list))
X
X(defmacro fast-nconc-cons (fast-nconc-list cons)
X  (once-only (fast-nconc-list)
X    `(progn (rplacd (car ,fast-nconc-list) ,cons)
X            (rplaca ,fast-nconc-list (cdar ,fast-nconc-list)))))
X
X(defmacro fast-nconc-item (fast-nconc-list item)
X  `(fast-nconc-cons ,fast-nconc-list (cons ,item nil)))
X
X#+Lucid
X(eval-when (compile load eval)
X  (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
X
X; rds 3/8 added -HP and +HP for make-keyword:
X#-HP
X(defun make-keyword (symbol)
X   (intern (symbol-name symbol) '#,(find-package 'keyword)))
X
X#+HP
X(defun make-keyword (symbol)
X   (intern (symbol-name symbol) (find-package 'keyword)))
X
X(defun string-append (&rest strings)
X  (setq strings (copy-list strings))        ;The explorer can't even
X                        ;rplaca an &rest arg?
X  (do ((string-loc strings (cdr string-loc)))
X      ((null string-loc)
X       (apply #'concatenate 'string strings))
X    (rplaca string-loc (string (car string-loc)))))
X
X(defun symbol-append (sym1 sym2 &optional (package *package*))
X  (intern (string-append sym1 sym2) package))
X
X(defmacro check-member (place list &key (test #'eql) (pretty-name place))
X  (once-only (place list)
X    `(or (member ,place ,list :test ,test)
X         (error "The value of ~A, ~S is not one of ~S."
X                ',pretty-name ,place ,list))))
X
X
X
X;;; A simple version of destructuring-bind.
X
X;;; This does no more error checking than CAR and CDR themselves do.  Some
X;;; attempt is made to be smart about preserving intermediate values.  It
X;;; could be better, although the only remaining case should be easy for
X;;; the compiler to spot since it compiles to PUSH POP.
X;;;
X;;; Common Lisp BUG:
X;;;    Common Lisp should have destructuring-bind.
X;;;
X(defmacro destructuring-bind (pattern form &body body)
X  (multiple-value-bind (ignore declares body)
X      (extract-declarations body)
X    (multiple-value-bind (setqs binds)
X    (destructure pattern form)
X      `(let ,binds
X     ,@declares
X     ,@setqs
X     . ,body))))
X
X(defun destructure (pattern form)
X  (declare (values setqs binds))
X  (let ((*destructure-vars* ())
X    (setqs ()))
X    (declare (special *destructure-vars*))
X    (when (not (symbolp form))
X      (setq *destructure-vars* '(.destructure-form.)
X        setqs (list `(setq .destructure-form. ,form)))
X      (setq form '.destructure-form.))
X    (values (nconc setqs (nreverse (destructure-internal pattern form)))
X        (delete nil *destructure-vars*))))
X
X(defun destructure-internal (pattern form)
X  ;; When we are called, pattern must be a list.  Form should be a symbol
X  ;; which we are free to setq containing the value to be destructured.
X  ;; Optimizations are performed for the last element of pattern cases.
X  ;; we assume that the compiler is smart about gensyms which are bound
X  ;; but only for a short period of time.
X  (declare (special *destructure-vars*))
X  (let ((gensym (gensym))
X    (pending-pops 0)
X    (var nil)
X    (setqs ()))
X    (labels
X        ((make-pop (var form pop-into)
X       (prog1
X         (cond ((zerop pending-pops)
X            `(progn ,(and var `(setq ,var (car ,form)))
X                ,(and pop-into `(setq ,pop-into (cdr ,form)))))
X           ((null pop-into)
X            (and var `(setq ,var ,(make-caxr pending-pops form))))
X           (t
X            `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
X                ,(and var `(setq ,var (pop ,pop-into))))))
X         (setq pending-pops 0))))
X      (do ((pat pattern (cdr pat)))
X      ((null pat) ())
X    (if (symbolp (setq var (car pat)))
X        (progn
X          (push var *destructure-vars*)
X          (cond ((null (cdr pat))
X             (push (make-pop var form ()) setqs))
X            ((symbolp (cdr pat))
X             (push (make-pop var form (cdr pat)) setqs)
X             (push (cdr pat) *destructure-vars*)
X             (return ()))
X            ((memq var '(nil ignore)) (incf pending-pops))
X            ((memq (cadr pat) '(nil ignore))
X             (push (make-pop var form ()) setqs)
X             (incf pending-pops 1))
X            (t
X             (push (make-pop var form form) setqs))))
X        (progn
X          (push `(let ((,gensym ()))
X               ,(make-pop gensym form (if (symbolp (cdr pat)) (cdr pat) form))
X               ,@(nreverse
X               (destructure-internal (if (consp pat) (car pat) pat)
X                         gensym)))
X            setqs)
X          (when (symbolp (cdr pat))
X        (push (cdr pat) *destructure-vars*)
X        (return)))))
X      setqs)))
X
X;;; Iterate is a simple iteration macro.  If CommonLisp had a standard Loop
X;;; macro I wouldn't need this wretched crock.  But what the hell, it seems
X;;; to do most of what I need.  It looks like:
X;;;   (iterate (<control-clause-1> <control-clause-2> ...)
X;;;      . <body>)
X;;;
X;;;  a control clause can be one of:
X;;;   (<var> in <list-form>)  | (<var> in <list-form> by <function>)
X;;;   (<var> on <list-form>)  | (<var> on <list-form> by <function>)
X;;;   (<var> from <initial> to <final>)
X;;;   (<var> from <initial> below <final>)
X;;;   (<var> from <initial> to <final> by <function> | <increment>)
X;;;   (<var> from <initial> below <final> by <function> | <increment>)
X;;;   (<var> = <form>)   <form> is evaluated each time through
X;;;   (<var> = <initial> <subsequent>)
X;;;
X;;;  inside <body> you are allowed to use:
X;;;    collect
X;;;    join
X;;;    sum
X
X(defvar *iterate-result-types* ())
X
X(defmacro define-iterate-result-type (name arglist &body body)
X  (let ((fn-name
X      (if (and (null (cdr body)) (symbolp (car body)))
X          (car body)
X          (make-symbol (string-append (symbol-name name) " iterate result type")))))
X    `(progn
X       (let ((existing (assq ',name  *iterate-result-types*)))
X     (if existing
X         (rplacd existing ',fn-name)
X         (push ',(cons name fn-name) *iterate-result-types*)))
X       ,(and (not (and (null (cdr body)) (symbolp (car body))))
X         `(defun ,fn-name ,arglist . ,body)))))
X
X(defmacro iterate (controls &body body)
X  #+Xerox (setq body (copy-tree body))
X  (let (binds var-init-steps
X    pre-end-tests post-end-tests
X    pre-bodies post-bodies
X    (result-type ()))
X    (mapc #'(lambda (control)
X          (let ((var (car control))
X            (type (cadr control))
X            (initial (caddr control))
X            (args (cdddr control)))
X        (ecase type
X          ((in on)
X           (let* ((gensym (if (or (eq type 'in) (consp var)) (gensym) var))
X              (step `(,(if args (cadr args) 'cdr) ,gensym)))
X             (push `(,gensym ,initial ,step) var-init-steps)
X             (push `(null ,gensym) pre-end-tests)
X             (cond ((listp var)
X                (multiple-value-bind (setqs dbinds)
X                (destructure var (if (eq type 'in) `(car ,gensym) gensym))
X                  (setq binds (nconc dbinds binds))
X                  (setq pre-bodies (nconc pre-bodies (nreverse setqs)))))
X               ((eq type 'in)
X                (push var binds)
X                (push `(setq ,var (car ,gensym)) pre-bodies)))))
X          (from
X            (let ((gensym (gensym))
X              (final
X                (and (memq (car args) '(to below))
X                 (if (eq (car args) 'to)
X                     (cadr args)
X                     `(- ,(cadr args) 1))))
X              (step
X                (progn (setq args (member 'by args))
X                   (cond ((null args)
X                      `(1+ ,var))
X                     ((numberp (cadr args))
X                      `(+ ,var ,(cadr args)))
X                     (t (cadr args))))))
X              (push `(,var ,initial ,step) var-init-steps)
X              (and final (push `(,gensym ,final) binds))
X              (and final (push `(> , var ,gensym) pre-end-tests))))
X          (=
X            (push `(,var ,initial ,(or (car args) initial))
X              var-init-steps))
X          )))
X      controls)
X    (setq body
X      (walk-form (cons 'progn body)
X             :walk-function
X             #'(lambda (form context &aux aux)
X             (ignore context)
X             (or (and (listp form)
X                  (setq aux (assq (car form) *iterate-result-types*))
X                  (setq result-type
X                    (if (null result-type)
X                        (funcall (cdr aux)
X                             form nil 'create-result-type)
X                        (funcall (cdr aux)
X                             form result-type 'check-result-type)))
X                  (funcall (cdr aux) form result-type 'macroexpand))
X                 form))))
X    (let* ((initially (cons 'progn
X                (dolist (tlf body)
X                  (when (and (consp tlf) (eq (car tlf) 'initially))
X                (return (prog1 (cdr tlf)
X                           (setf (car tlf) 'progn
X                             (cdr tlf) ())))))))
X       (finally (cons 'progn
X              (dolist (tlf body)
X                (when (and (consp tlf) (eq (car tlf) 'finally))
X                  (return (prog1 (cdr tlf)
X                         (setf (car tlf) 'progn
X                           (cdr tlf) ()))))))))
X      `(let (,@binds . ,(caddr result-type))
X     (iterate-macrolets
X       (prog ,(mapcar #'(lambda (x) (list (car x) (cadr x)))
X              var-init-steps)
X         ,initially
X          restart
X         (and (or . ,(reverse pre-end-tests))
X              (go .iterate_return.))
X         (progn . ,(reverse pre-bodies))
X         ,body
X         (progn . ,(reverse post-bodies))
X         (or ,@post-end-tests
X             (progn ,@(mapcar #'(lambda (x)
X                      (and (cddr x)
X                           `(setq ,(car x)
X                              ,(caddr x))))
X                      var-init-steps)
X                (go restart)))
X          .iterate_return.
X         ,finally
X         (return ,(cadddr result-type))))))))
X
X(define-iterate-result-type collect (form result-type op)
X  iterate-collect-join)
X
X(define-iterate-result-type join (form result-type op)
X  iterate-collect-join)
X
X(defun iterate-collect-join (form result-type op)
X  (ecase op
X    (create-result-type
X      (let ((gensym (gensym)))
X    `(,(car form) ,gensym ((,gensym ())) (nreverse ,gensym))))
X    (check-result-type
X      (if (memq (car result-type) '(collect join))
X      result-type
X      (error "Using ~S inside an iterate in which you already used ~S."
X         (car form) (car result-type))))
X    (macroexpand
X      (if (eq (car form) 'collect)
X      `(push ,(cadr form) ,(cadr result-type))
X      `(setq ,(cadr result-type)
X         (append (reverse ,(cadr form)) ,(cadr result-type)))))))
X
X(define-iterate-result-type sum (form result-type op)
X  (ecase op
X    (create-result-type
X      (let ((gensym (gensym)))
X    `(,(car form) ,gensym ((,gensym 0)) ,gensym)))
X    (check-result-type
X      (eq (car result-type) 'sum))
X    (macroexpand
X      `(incf ,(cadr result-type) ,(cadr form)))))
X
X(defmacro iterate-macrolets (&body body)
X  `(macrolet
X     ((until (test)
X        `(when ,test (go .iterate_return.)))
X      (while (test)
X    `(until (not ,test)))
X      (initially (&body body)
X    (error
X      "It is an error for FINALLY to appear other than at top-level~%~
X       inside an iterate."))
X      (finally (&body ignore)
X    (error
X      "It is an error for INITIALLY to appear other than at top-level~%~
X           inside an iterate."))
X      )
X     . ,body))
X
X;;;
X;;; Two macros useful for parsing defstructs.
X;;; The first parses slot-description (or lambda-list) style keyword-value
X;;; pairs.  The second, more complicated one, parses defstruct option style
X;;; keyword-value pairs.
X;;;
X(defmacro keyword-bind (keywords form &body body)
X  `(apply (function (lambda (&key . ,keywords) . ,body)) ,form))
X
X;;;
X;;;   (keyword-parse (<keyword-spec-1> <keyword-spec-2> ..)
X;;;                  form
X;;;      . body)
X;;;
X;;; Where form is a form which will be evaluated and should return the list
X;;; of keywords and values which keyword-parse will parse.  Body will be
X;;; evaluated with the variables specified by the keyword-specs bound.
X;;; Keyword specs look like:
X;;;        <var>
X;;;        (<var> <default>)
X;;;        (<var> <default> <suppliedp var>)
X;;;        (<var> <default> <suppliedp var> <option-1> <val-1> ...)
X;;;
X;;;    The options can be:
X;;;       :allowed     ---  :required   :multiple
X;;;       :return-cdr  ---  t           nil
X;;;
X(defmacro keyword-parse (keywords form &body body)
X  ;; This makes an effort to resemble keyword-bind in that the vars are bound
X  ;; one at a time so that a default value form can look at the value of a
X  ;; previous argument. This is probably more hair than its worth, but what
X  ;; the hell, programming is fun.
X  (let* ((lambda-list ())
X         (supplied-p-gensyms ())
X         (value-forms ())
X         (entry-var (gensym)))
X    (dolist (kw keywords)
X      (unless (listp kw) (setq kw (list kw)))
X      (destructuring-bind (var default supplied-p-var . options) kw
X        (keyword-bind (presence (allowed ':required) return-cdr) options
X          (push var lambda-list)
X          (when supplied-p-var
X            (push supplied-p-var lambda-list)
X            (push (gensym) supplied-p-gensyms))
X          (push `(let ((,entry-var (keyword-parse-assq ',(make-keyword var)
X                               ,form
X                               ',allowed)))
X                   (if (null ,entry-var)
X                       ,default
X                       ;; Insert appropriate error-checking based on the
X                       ;; allowed argument.
X                       (progn
X                       ,(when (null allowed)
X                          `(unless (nlistp (car ,entry-var))
X                             (error "The ~S keyword was supplied with an ~
X                                    argument, it is not allowed to have one."
X                                    ',(make-keyword var))))
X                       ,(when (eq allowed ':required)
X                          `(unless (listp (car ,entry-var))
X                             (error
X                   "The ~S keyword was supplied without an ~
X                                argument~%when present, this keyword must ~
X                                have an argument."
X                               ',(make-keyword var))))
X                       (cond ((listp (car ,entry-var))
X                              ,(and supplied-p-var
X                                    `(setq ,(car supplied-p-gensyms) 't))
X                              ,(if return-cdr
X                   (if (eq allowed ':multiple)
X                       `(mapcar #'cdr ,entry-var)
X                       `(cdar ,entry-var))
X                   (if (eq allowed ':multiple)
X                       `(mapcar #'cadr ,entry-var)
X                       `(cadar ,entry-var))))
X                             (t
X                              ,(and supplied-p-var
X                                    `(setq ,(car supplied-p-gensyms)
X                       ':presence))
X                              ,presence)))))
X                value-forms)
X          (when supplied-p-var
X            (push (car supplied-p-gensyms) value-forms)))))
X    `(let ,supplied-p-gensyms
X       ((lambda ,(reverse lambda-list) . ,body) . ,(reverse value-forms)))))
X
X
X(defun keyword-parse-assq (symbol list allowed)
X  (do ((result nil result)
X       (tail list (cdr tail)))
X      ((null tail) (nreverse result))
X    (if (eq (if (symbolp (car tail)) (car tail) (caar tail)) symbol)
X    (if (neq allowed ':multiple)
X        (return tail)
X        (push (car tail) result)))))
X
X  ;;
X;;;;;; printing-random-thing
X  ;;
X;;; Similar to printing-random-object in the lisp machine but much simpler
X;;; and machine independent.
X(defmacro printing-random-thing ((thing stream) &body body)
X  (once-only (stream)
X  `(let ((*print-level* (and (numberp *print-level*) (- *print-level* 1))))
X     (progn (princ "#<" ,stream)
X            ,@body
X        (princ " " ,stream)
X        (printing-random-thing-internal ,thing ,stream)
X        (princ ">" ,stream)))))
X
X(defun printing-random-thing-internal (thing stream)
X  (ignore thing stream)
X  nil)
X
X  ;;
X;;;;;;
X  ;;
X
X(defun capitalize-words (string)
X  (let ((string (copy-seq (string string))))
X    (declare (string string))
X    (do* ((flag t flag)
X      (length (length string) length)
X      (char nil char)
X      (i 0 (+ i 1)))
X     ((= i length) string)
X      (setq char (elt string i))
X      (cond ((both-case-p char)
X         (if flag
X         (and (setq flag (lower-case-p char))
X              (setf (elt string i) (char-upcase char)))
X         (and (not flag) (setf (elt string i) (char-downcase char))))
X         (setq flag nil))
X        ((char-equal char #\-)
X         (setq flag t))
X        (t (setq flag nil))))))
X
X  ;;
X;;;;;; CLASS-NAMED  naming classes.
X  ;;
X;;;
X;;; (CLASS-NAMED <name>) returns the class named <name>.  setf can be used
X;;; with class-named to set the class named <name>.  These are "extrinsic"
X;;; names.  Neither class-named nor setf of class-named do anything with the
X;;; name slot of the class, they only lookup and change the association from
X;;; name to class.
X;;;
X
X(defvar *class-name-hash-table* (make-hash-table :test #'eq))
X
X(defun class-named (name &optional no-error-p)
X  (or (gethash name *class-name-hash-table*)
X      (if no-error-p () (error "No class named: ~S." name))))
X
X(defsetf class-named (name &optional ignore-damnit) (class)
X  `(setf (gethash ,name *class-name-hash-table*) ,class))
X
X
X(defvar *discriminator-name-hash-table* (make-hash-table :test #'eq
X                             :size 1000))
X
X(defun discriminator-named (name)                ;This a function for
X  (gethash name *discriminator-name-hash-table*))    ;the benefit of
X                                ;compile-time-define?
X
X(defun set-discriminator-named (name new-value)
X  (setf (gethash name *discriminator-name-hash-table*) new-value))
X
X(defsetf discriminator-named set-discriminator-named)
X
X;;;
X;;; To define a macro which is only applicable in the body of a defmethod,
X;;; use define-method-body-macro.  This macro takes two arguments the name
X;;; of the macro that should be defined in the body of the method and the
X;;; function which should be called to expand calls to that macro.
X;;;
X;;; Expander-function will be called with 3 arguments:
X;;;
X;;;   the entire macro form (gotten with &whole)
X;;;   the macroexpand-time-information
X;;;   the environment
X;;;
X
X(defvar *method-body-macros* ())
X
X(defmacro define-method-body-macro (name arglist &key global method)
X  (when (eq global :error)
X    (setq global
X      `(progn (warn "~S used outside the body of a method." ',name)
X          '(error "~S used outside the body of a method." ',name))))
X  (or method
X      (error "Have to provide a value for the method-body definition of~%~
X              a macro defined with define-method-body-macro."))
X  #+KCL (when (memq '&environment arglist)
X      ;; In KCL, move &environment to the beginning of the
X      ;; arglist since they require that it be there.
X      (unless (eq (car arglist) '&environment)
X        (do ((loc arglist (cdr loc)))
X        ((eq (cadr loc) '&environment)
X         (setq arglist (list* (cadr loc) (caddr loc) arglist))
X         (setf (cdr loc) (cdddr loc))))))
X  (let ((body-expander-function (gensym))
X    (parameters (remove lambda-list-keywords arglist
X                :test #'(lambda (x y) (member y x)))))
X    `(eval-when (compile load eval)
X       ,(and global `(defmacro ,name ,arglist ,global))
X       (defun ,body-expander-function
X          (macroexpand-time-environment ,@parameters)
X     ,method)
X
X       (let ((entry (or (assq ',name *method-body-macros*)
X            (progn (push (list ',name) *method-body-macros*)
X                   (car *method-body-macros*)))))
X     (setf (cdr entry) (list ',arglist
X                 ',parameters
X                 ',body-expander-function))))))
X
X  ;;
X;;;;;; Special variable definitions.
X  ;;
X;;; Gets set to its right value once early-defmeths are fixed.
X;;;
X(defvar *error-when-defining-method-on-existing-function* 'bootstrapping
X  "If this variable is non-null (the default) defmethod signals an error when
X   a method is defined on an existing lisp-function without first calling
X   make-specializable on that function.")
X
END_OF_FILE
if test 25561 -ne `wc -c <'macros.l'`; then
    echo shar: \"'macros.l'\" unpacked with wrong size!
fi
# end of 'macros.l'
fi
echo shar: End of archive 7 \(of 13\).
cp /dev/null ark7isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]